home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / sys / table_entry.t < prev    next >
Text File  |  1988-05-02  |  10KB  |  273 lines
  1. (herald table_entry
  2.   (env tsys (osys table)))
  3.  
  4. ;;;                           Hashing
  5. ;;;============================================================================
  6.  
  7. ;;; This procedure attempts to improve on the user supplied hashing procedure.
  8. ;;; Testing show that it slightly improves DESCRIPTOR-HASH.
  9.  
  10. (define-integrable (second-hash n)
  11.   (let ((low (fixnum-logand n 255)))
  12.     (fixnum-logand (fixnum-logxor (fixnum-logxor low (fixnum-ashl low 3))
  13.                        (fixnum-logxor (fixnum-ashr n 7)
  14.                            (fixnum-logxor (fixnum-ashl n 6)
  15.                                           (fixnum-ashr n 16))))
  16.                    most-positive-fixnum)))
  17.  
  18. (define (descriptor-hash p)
  19.   (descriptor->fixnum p))
  20.  
  21. ;;; Rehash and cut with MASK
  22.  
  23. (define-integrable (really-table-hash key hash mask)
  24.   (fixnum-logand (fixnum-ashl (second-hash (hash key))
  25.                               3)
  26.                  mask))
  27.  
  28. ;;; Keep hashing until HASH and TABLE are of the same GC generation.  Tables
  29. ;;; with mask 0 have only a single bucket and thus do not need hashing.
  30.  
  31. (define (table-hash table key)
  32.   (cond ((fx= (%table-mask table) 0)
  33.          0)
  34.         ((not (%table-gc-stamp table))
  35.          (really-table-hash key (%table-hash table) (%table-mask table)))
  36.         (else
  37.          (iterate loop ()
  38.            (let* ((hash (really-table-hash key
  39.                                            (%table-hash table)
  40.                                            (%table-mask table)))
  41.                   (stamp (%table-gc-stamp table)))
  42.              (cond ((neq? (gc-stamp) stamp)
  43.                     (table-rehash table (%table-count table))
  44.                     (loop))
  45.                    (else
  46.                     hash)))))))
  47.  
  48. ;;;                     TABLE-ENTRY and friends
  49. ;;;===========================================================================
  50.  
  51. (define table-entry
  52.   (object (lambda (table key)
  53.             (let* ((table (enforce %table? table))
  54.                    (hash (table-hash table key))
  55.                    (comparator (%table-compare table))
  56.                    (vec (%table-vector table)))
  57.               (receive (found? index)
  58.                        (find-table-index key vec hash comparator)
  59.                 (if found? (vref vec index) nil))))
  60.     ((setter self) %set-table-entry)))
  61.  
  62. ;;; Speed hack for common case - get EQ? tests generated inline (at some cost
  63. ;;; in code size).
  64.  
  65. (define-integrable (find-table-index key vec hash comparator)
  66.   (if (eq? comparator eq?)
  67.       (really-find-table-index key vec hash eq?)
  68.       (really-find-table-index key vec hash comparator)))
  69.  
  70. ;;; Look for KEY in the hash bucket of VEC that starts at HASH.  Returns a
  71. ;;; flag and an index.  If the flag is #T then the index is the index of the
  72. ;;; key in the vector.  If the flag is #F then the key was not found and the
  73. ;;; index is the index of the end of the bucket.
  74.  
  75. (define-integrable (really-find-table-index key vec hash comparator)
  76.   (iterate loop ((i hash))
  77.     (cond ((vref vec i)
  78.            (if (comparator key (vref vec (fx+ i 1)))
  79.                (return t i)
  80.                (loop (fx+ i 2))))
  81.           ((vref vec (fx+ i 1))
  82.            => loop)
  83.           (else
  84.            (return nil i)))))
  85.  
  86. ;;;                     SET-TABLE-ENTRY and friends
  87. ;;;===========================================================================
  88.  
  89. ;;; If the table is full, rehash with a slightly larger size.  If it is still
  90. ;;; full, there are hashing problems so go a lot bigger.
  91.  
  92. (define (%set-table-entry table key value)
  93.   (let ((table (enforce %table? table)))
  94.     (cond ((not value)
  95.            (if (%remove-table-entry key table)
  96.                (modify (%table-count table)
  97.                        (lambda (x) (fx- x 1)))))
  98.           (else
  99.            (iterate loop ((new-size (fx+ 1 (%table-count table))))
  100.              (cond ((not (really-set-table-entry key value table))
  101.                     (table-rehash table new-size)
  102.                     (loop (fx-ashl new-size 1)))))))
  103.     value))
  104.  
  105. ;;; Add KEY and VALUE to TABLE, incrementing the count.
  106.  
  107. (define (set-table-vec table vec index key value)
  108.   (modify (%table-count table) (lambda (c) (fx+ c 1)))
  109.   (set (vref vec index) value)
  110.   (set (vref vec (fx+ index 1)) key)
  111.   t)
  112.  
  113. ;;; Try to set the value of KEY in TABLE to be VALUE.  Returns #t is successful
  114. ;;; and #f if the table is too full.
  115. ;;;
  116. ;;; FIND-TABLE-INDEX looks for KEY in the table.  If it is already there the
  117. ;;; value is changed.  Otherwise there are three possibilities:
  118. ;;;   The table has only one bucket:
  119. ;;;      If it's full return #F, otherwise add VALUE at the end.
  120. ;;;   There is room in the current bucket:
  121. ;;;      Add VALUE at the end.
  122. ;;;   Otherwise:
  123. ;;;      If there are no free overflow buckets return #F, otherwise
  124. ;;;      allocate an overflow bucket and put put VALUE in it.
  125. ;;;
  126. ;;; This is integrable because it is only called in one place.
  127.  
  128. (define-integrable (really-set-table-entry key value table)
  129.   (let* ((hash (table-hash table key))
  130.          (comparator (%table-compare table))
  131.          (vec (%table-vector table)))
  132.     (receive (found? index)
  133.              (find-table-index key vec hash comparator)
  134.       (cond (found?
  135.              (set (vref vec index) value)
  136.              t)
  137.             ((fx= 0 (%table-mask table))
  138.              (if (fx>= (fx+ index 2) (vector-length vec))
  139.                  nil
  140.                  (set-table-vec table vec index key value)))
  141.             ((fx> 6 (fixnum-logand index 7))
  142.              (set-table-vec table vec index key value))
  143.             (else
  144.              (let ((next (%table-next table)))
  145.                (cond ((fx>= next (vector-length vec))
  146.                       nil)
  147.                      (else
  148.                       (set (%table-next table) (fx+ next 8))
  149.                       (set (vref vec (fx+ 1 index)) next)
  150.                       (set-table-vec table vec next key value)))))))))
  151.  
  152. ;;; Speed hack for common case - get EQ? tests generated inline (at some cost
  153. ;;; in code size).
  154. ;;;
  155. ;;; This is integrable because it is only called in one place.
  156.  
  157. (define-integrable (%remove-table-entry key table)
  158.   (let* ((i (table-hash table key))
  159.          (comparator (%table-compare table))
  160.          (vec (%table-vector table)))
  161.     (if (eq? comparator eq?)
  162.         (really-remove-table-entry vec key i eq?)
  163.         (really-remove-table-entry vec key i comparator))))
  164.  
  165. ;;; Look for KEY and remove it if you find it.
  166.  
  167. (define-integrable (really-remove-table-entry vec key hash comparator)
  168.   (iterate loop ((i hash))
  169.     (cond ((vref vec i)
  170.            (if (comparator key (vref vec (fx+ i 1)))
  171.                (remove-entry vec i)
  172.                (loop (fx+ i 2))))
  173.           ((vref vec (fx+ i 1))
  174.            => loop)
  175.           (else nil))))     ; must return NIL here
  176.  
  177. ;;; Remove the vector entry at I and slide the rest of the bucket down one.
  178. ;;; This is the real cost of using vectors instead of lists.
  179.  
  180. (define (remove-entry vec i)
  181.   (iterate loop ((i i))
  182.     (set (vref vec i) (vref vec (fx+ i 2)))
  183.     (set (vref vec (fx+ i 1)) (vref vec (fx+ i 3)))
  184.     (cond ((vref vec i)
  185.            (loop (fx+ i 2)))
  186.           ((vref vec (fx+ i 1))
  187.            => (lambda (j)
  188.                 (set (vref vec i) (vref vec j))
  189.                 (set (vref vec (fx+ i 1)) (vref vec (fx+ j 1)))
  190.                 (loop j)))
  191.           (else t))))       ; must return T here
  192.  
  193.  
  194. ;;;                           TABLE-REHASH
  195. ;;;============================================================================
  196.  
  197. ;;;   Rehash TABLE because of a GC or a change in size.  Get a new vector, move
  198. ;;; all the values into it, and release the old vector.  Some calls to this
  199. ;;; do not want the vector to be reused.
  200.  
  201. (define (table-rehash table new-size)
  202.   (release-table-vector (really-table-rehash table new-size))
  203.   table)
  204.  
  205. (define (really-table-rehash table new-size)
  206.   (let ((vec (%table-vector table))
  207.         (old-mask (%table-mask table)))
  208.     (receive (new mask next)
  209.              (get-table-vector new-size)
  210.       (set (%table-mask   table) mask)
  211.       (set (%table-vector table) new)
  212.       (if (%table-gc-stamp table)                    ; This must be before any
  213.           (set (%table-gc-stamp table) (gc-stamp)))  ; hashing.
  214.       (cond ((fx= 0 mask)
  215.              (simple-rehash-values vec new (%table-next table))
  216.              (set (%table-next table) next))
  217.             ((rehash-values vec
  218.                             new
  219.                             (%table-hash table)
  220.                             mask
  221.                             next
  222.                             (%table-next table))
  223.              => (lambda (next)
  224.                   (set (%table-next table) next)))
  225.             (else             ; This is extremely unlikely
  226.              (set (%table-mask table) old-mask)
  227.              (set (%table-vector table) vec)
  228.              (really-table-rehash table (fx* new-size 2)))))
  229.     vec))
  230.  
  231. ;;;   Move all the values from OLD to NEW.  MASK is the mask of NEW, NEXT is
  232. ;;; the first overflow bucket in NEW, LEN how far we have to go in OLD.  Most
  233. ;;; of this procedure is a version of REALLY-FIND-TABLE-INDEX and
  234. ;;; REALLY-SET-TABLE-ENTRY.
  235.  
  236. (define (rehash-values old new hasher mask next len)
  237.   (iterate i-loop ((i 0) (next next))
  238.     (cond ((fx>= i len)
  239.            next)
  240.           ((not (vref old i))
  241.            (i-loop (fx+ i 2) next))
  242.           (else
  243.            (let ((k (vref old (fx+ i 1))))
  244.              (iterate j-loop ((j (really-table-hash k hasher mask)))
  245.                (cond ((vref new j)
  246.                       (j-loop (fx+ 2 j)))
  247.                      ((vref new (fx+ 1 j))
  248.                       => j-loop)
  249.                      ((fx> 6 (fixnum-logand j 7))
  250.                       (set (vref new j) (vref old i))
  251.                       (set (vref new (fx+ 1 j)) k)
  252.                       (i-loop (fx+ i 2) next))
  253.                      ((fx>= next (vector-length new))
  254.                       nil)
  255.                      (else
  256.                       (set (vref new (fx+ 1 j)) next)
  257.                       (set (vref new next) (vref old i))
  258.                       (set (vref new (fx+ 1 next)) k)
  259.                       (i-loop (fx+ i 2) (fx+ next 8))))))))))
  260.  
  261. (define (simple-rehash-values old new len)
  262.   (iterate loop ((i 0) (next 0))
  263.     (cond ((fx>= i len)
  264.            (return))
  265.           ((not (vref old i))
  266.            (loop (fx+ i 2) next))
  267.           (else
  268.            (set (vref new next) (vref old i))
  269.            (set (vref new (fx+ 1 next)) (vref old (fx+ i 1)))
  270.            (loop (fx+ i 2) (fx+ 2 next))))))
  271.  
  272.  
  273.